home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Snippets / PNL Libraries / MyFileSystemUtils.p < prev    next >
Encoding:
Text File  |  1997-04-05  |  20.5 KB  |  816 lines  |  [TEXT/CWIE]
  1. unit MyFileSystemUtils;
  2.  
  3. interface
  4.  
  5.     uses
  6.         Types, Files, AppleTalk;
  7.  
  8.     type
  9.         ScanProc = function(var fs:FSSpec; folder:boolean; path:Str255; var pb:CInfoPBRec):boolean;
  10. { for folders, return true to scan contents }
  11. { for files return true if you delete the file - other changes to the file system would be bad... }
  12.         
  13.     procedure MyResolveAliasFile (var fs: FSSpec);
  14.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: Str63; index: integer; var pb: CInfoPBRec): OSErr;
  15.     function FSpGetCatInfo (const fs: FSSpec; var pb: CInfoPBRec): OSErr;
  16.     function FSpGetIndCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  17.     function FSpSetCatInfo (const spec: FSSpec; var pb: CInfoPBRec): OSErr;
  18.     function FSpGetParID( const spec: FSSpec; var dirID: longint ): OSErr;
  19.     function FSpGetDirID( const spec: FSSpec; var dirID: longint ): OSErr;
  20.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  21.     procedure MyGetModDate (const spec: FSSpec; var moddate: longint);
  22.     function DuplicateFile (const org, new: FSSpec): OSErr;
  23.     function CopyData (src, dst: integer; len: longint): OSErr;
  24.     function TouchDir (fs: FSSpec): OSErr;
  25.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  26.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  27.     function CreateUniqueFolder (var fs: FSSpec; var dirID: longint ): OSErr;
  28.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  29.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  30.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  31.     function MyFSRead(refnum: integer; len: longint; p: Ptr): OSErr;
  32.     function MyFSWriteString( refnum: integer; const s: string ): OSErr;
  33.     function MyFSWrite (refnum: integer; len: longint; p: Ptr): OSErr;
  34.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: Ptr): OSErr;
  35.     function MyFSReadAt (refnum: integer; pos, len: longint; p: Ptr): OSErr;
  36.     function MyFSReadFile( const spec: FSSpec; var data: Handle ): OSErr;
  37.     function FSSpecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  38.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  39.     function DiskSize (vrn: integer): longint; { result in k }
  40.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  41.     function SameFSSpec (const fs1, fs2: FSSpec): boolean;
  42.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  43.     procedure SetSFLocation (vrn: integer; dirID: longint);
  44.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  45.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  46.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  47.     function FSpGetFolderDirID( const spec: FSSpec; var dirID: longint ): OSErr;
  48.     function GetVolInfo (var name: Str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  49.     function GetVolumeAddrBlock(vrn: integer; index: integer; var addr: AddrBlock): OSErr;
  50.     function ScanDirectory (fs: FSSpec; doit: ScanProc): OSErr;
  51.     function RemoveResourceFork( const spec: FSSpec ): OSErr;
  52.     
  53. implementation
  54.  
  55.     uses
  56.         Memory, Files, Finder, Errors, TextUtils, OSUtils, Packages, GestaltEqu, Folders, Aliases, LowMem, Devices,
  57.         MyTypes, MyStrings, MyMemory, MyMathUtils;
  58.  
  59.     procedure SafeFindFolder (vRefNum: integer; folderType: OSType; var foundVRefNum: integer; var foundDirID: longint);
  60.         var
  61.             theWorld: SysEnvRec;
  62.             gv: longint;
  63.     begin
  64.         foundVRefNum := -1;
  65.         foundDirID := 2;
  66.         if (Gestalt(gestaltFindFolderAttr, gv) <> noErr) | (not BTST(gv, gestaltFindFolderPresent)) | (FindFolder(vRefNum, folderType, true, foundVRefNum, foundDirID) <> noErr) then begin
  67.             if SysEnvirons(1, theWorld) = noErr then begin
  68.                 foundVRefNum := theWorld.sysVRefNum;
  69.                 foundDirID := 0;
  70.             end else begin
  71.                 foundVRefNum := -1;
  72.                 foundDirID := 2;
  73.             end;
  74.         end;
  75.     end;
  76.  
  77.     function CreateTemporaryFile (var fs: FSSpec): OSErr;
  78.     begin
  79.         SafeFindFolder( kOnSystemDisk, kTemporaryFolderType, fs.vRefNum, fs.parID );
  80.         CreateTemporaryFile := CreateUniqueFile( fs, 'trsh', 'trsh' );
  81.     end;
  82.  
  83.     procedure GetSFLocation (var vrn: integer; var dirID: longint);
  84.     begin
  85.         vrn:= -LMGetSFSaveDisk;
  86.         dirID:=LMGetCurDirStore;
  87.     end;
  88.  
  89.     procedure SetSFLocation(vRefNum: integer; dirID: longint);
  90.         var
  91.             b21: Ptr;
  92.             sysVersion: longint;
  93.     begin
  94.     {    from Mark Romano @ Symantec: System 7.5 has a low-memory global that        }
  95.     {    controls Standard File. To force it to use SFSaveDisk/CurDirStore, clear bit 3.    }
  96.  
  97.         if (Gestalt(gestaltSystemVersion, sysVersion) = noErr) & (sysVersion >= $0750) then begin
  98.             b21 := Pointer($0B21);
  99.             b21^ := BAND(b21^, GoodBNOT($04));
  100.         end;
  101.  
  102.         LMSetSFSaveDisk(-vRefNum);
  103.         LMSetCurDirStore(dirID);
  104.     end;
  105.  
  106.     function FSSpecToFullPath (fs: FSSpec; var path: Str255): OSErr;
  107.         var
  108.             err: OSErr;
  109.             pb: CInfoPBRec;
  110.             s: Str63;
  111.     begin
  112.         s := fs.name;
  113.         err := FSMakeFSSpec(fs.vRefNum, fs.parID, s, fs);
  114.         if err = fnfErr then begin
  115.             err := noErr;
  116.         end;
  117.         if err = noErr then begin
  118.             if fs.parID = 1 then begin
  119.                 path := concat(fs.name, ':');
  120.             end else begin
  121.                 path := fs.name;
  122.                 while (err = noErr) & (fs.parID <> 1) do begin
  123.                     err := FSpGetIndCatInfo(fs, -1, pb);
  124.                     path := concat(fs.name, ':', path);
  125.                     fs.parID := pb.ioFlParID;
  126.                 end;
  127.             end;
  128.         end;
  129.         FSSpecToFullPath := err;
  130.     end;
  131.  
  132.     function TouchDir (fs: FSSpec): OSErr;
  133.         var
  134.             pb: CInfoPBRec;
  135.             err: OSErr;
  136.     begin
  137.         if fs.name = '' then begin
  138.             TouchDir := TouchFolder(fs.vRefNum, fs.parID);
  139.         end else begin
  140.             pb.ioVRefNum := fs.vRefNum;
  141.             pb.ioDirID := fs.parID;
  142.             pb.ioNamePtr := @fs.name;
  143.             pb.ioFDirIndex := 0;
  144.             err := PBGetCatInfoSync(@pb);
  145.             if err = noErr then begin
  146.                 pb.ioNamePtr := nil;
  147.                 GetDateTime(pb.ioDrMdDat);
  148.                 err := PBSetCatInfoSync(@pb);
  149.             end;
  150.             TouchDir := err;
  151.         end;
  152.     end;
  153.  
  154.     function TouchFolder (vrn: integer; dirID: longint): OSErr;
  155.         var
  156.             pb: CInfoPBRec;
  157.             err: OSErr;
  158.     begin
  159.         pb.ioVRefNum := vrn;
  160.         pb.ioDirID := dirID;
  161.         pb.ioNamePtr := nil;
  162.         pb.ioFDirIndex := -1;
  163.         err := PBGetCatInfoSync(@pb);
  164.         if err = noErr then begin
  165.             pb.ioVRefNum := vrn;
  166.             pb.ioDirID := dirID;
  167.             pb.ioNamePtr := nil;
  168.             GetDateTime(pb.ioDrMdDat);
  169.             err := PBSetCatInfoSync(@pb);
  170.         end;
  171.         TouchFolder := err;
  172.     end;
  173.  
  174.     function CreateUniqueFile (var fs: FSSpec; creator, ftype: OSType): OSErr;
  175.         var
  176.             oname: Str255;
  177.             n: Str255;
  178.             i: integer;
  179.             oe: OSErr;
  180.     begin
  181.         oname := fs.name;
  182.         LimitStringLength(oname, 27, '…');
  183.         oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  184.         i := 1;
  185.         while oe = dupFNErr do begin
  186.             NumToString(i, n);
  187.             fs.name := concat(oname, '#', n);
  188.             oe := HCreate(fs.vRefNum, fs.parID, fs.name, creator, ftype);
  189.             i := i + 1;
  190.         end;
  191.         CreateUniqueFile := oe;
  192.     end;
  193.  
  194.     function CreateUniqueFolder (var fs: FSSpec; var dirID: longint ): OSErr;
  195.         var
  196.             oname: Str255;
  197.             n: Str255;
  198.             i: integer;
  199.             oe: OSErr;
  200.     begin
  201.         oname := fs.name;
  202.         LimitStringLength( oname, 27, '…' );
  203.         oe := FSpDirCreate( fs, 0, dirID );
  204.         i := 1;
  205.         while oe = dupFNErr do begin
  206.             NumToString( i, n );
  207.             fs.name := concat(oname, '#', n);
  208.             oe := FSpDirCreate( fs, 0, dirID );
  209.             i := i + 1;
  210.         end;
  211.         CreateUniqueFolder := oe;
  212.     end;
  213.     
  214.     function MyFSReadAt (refnum: integer; pos, len: longint; p: Ptr): OSErr;
  215.         var
  216.             pb: ParamBlockRec;
  217.             oe: OSErr;
  218.     begin
  219.         pb.ioRefNum := refnum;
  220.         pb.ioBuffer := p;
  221.         pb.ioReqCount := len;
  222.         pb.ioPosMode := fsFromStart;
  223.         pb.ioPosOffset := pos;
  224.         oe := PBReadSync(@pb);
  225.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  226.             oe := -1;
  227.         end;
  228.         MyFSReadAt := oe;
  229.     end;
  230.  
  231.     function MyFSReadLineEOL (refnum: integer; ch: char; var s: Str255): OSErr;
  232.         var
  233.             pb: ParamBlockRec;
  234.             err: OSErr;
  235.     begin
  236.         pb.ioRefNum := refnum;
  237. {$PUSH}
  238. {$R-}
  239.         pb.ioBuffer := @s[1];
  240.         pb.ioReqCount := SizeOf(s) - 1;
  241.         pb.ioPosMode := fsFromMark + fsNewLine + BSL(ord(ch), 8);
  242.         pb.ioPosOffset := 0;
  243.         err := PBReadSync(@pb);
  244.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  245.             err := noErr;
  246.         end;
  247.         if err = noErr then begin
  248.             if s[pb.ioActCount] = ch then begin
  249.                 pb.ioActCount := pb.ioActCount - 1;
  250.             end;
  251.             s[0] := chr(pb.ioActCount);
  252.         end;
  253. {$POP}
  254.         MyFSReadLineEOL := err;
  255.     end;
  256.  
  257.     function MyFSReadLine (refnum: integer; var s: Str255): OSErr;
  258.     begin
  259.         MyFSReadLine := MyFSReadLineEOL(refnum, cr, s);
  260.     end;
  261.  
  262.     function MyFSReadLineAt (refnum: integer; pos: longint; var s: Str255): OSErr;
  263.         var
  264.             pb: ParamBlockRec;
  265.             err: OSErr;
  266.     begin
  267.         pb.ioRefNum := refnum;
  268. {$PUSH}
  269. {$R-}
  270.         pb.ioBuffer := @s[1];
  271.         pb.ioReqCount := SizeOf(s) - 1;
  272.         pb.ioPosMode := fsFromStart + fsNewLine + BSL(ord(cr), 8);
  273.         pb.ioPosOffset := pos;
  274.         err := PBReadSync(@pb);
  275.         if (err = eofErr) & (pb.ioActCount > 0) then begin
  276.             err := noErr;
  277.         end;
  278.         if err = noErr then begin
  279.             s[0] := chr(pb.ioActCount - 1);
  280.         end;
  281. {$POP}
  282.         MyFSReadLineAt := err;
  283.     end;
  284.  
  285.     function MyFSRead(refnum: integer; len: longint; p: Ptr): OSErr;
  286.         var
  287.             err: OSErr;
  288.             count: longint;
  289.     begin
  290.         err := noErr;
  291.         if len > 0 then begin
  292.             count := len;
  293.             err := FSRead(refnum, count, p);
  294.             if (err = noErr) & (count <> len) then begin
  295.                 err := -1;
  296.             end;
  297.         end;
  298.         MyFSRead := err;
  299.     end;
  300.  
  301.     function MyFSWriteString( refnum: integer; const s: string ): OSErr;
  302.     begin
  303.         MyFSWriteString := MyFSWrite( refnum, length(s), @s[1] );
  304.     end;
  305.     
  306.     function MyFSWrite (refnum: integer; len: longint; p: Ptr): OSErr;
  307.         var
  308.             oe: OSErr;
  309.             count: longint;
  310.     begin
  311.         oe := noErr;
  312.         if len > 0 then begin
  313.             count := len;
  314.             oe := FSWrite(refnum, count, p);
  315.             if (oe = noErr) & (count <> len) then begin
  316.                 oe := -1;
  317.             end;
  318.         end;
  319.         MyFSWrite := oe;
  320.     end;
  321.  
  322.     function MyFSReadFile( const spec: FSSpec; var data: Handle ): OSErr;
  323.         var
  324.             err, junk: OSErr;
  325.             rn: integer;
  326.             filelen: longint;
  327.     begin
  328.         data := nil;
  329.         err := FSpOpenDF( spec, fsRdPerm, rn );
  330.         if err = noErr then begin
  331.             err := GetEOF( rn,  filelen );
  332.             if err = noErr then begin
  333.                 err := MNewHandle( data, filelen );
  334.                 if err = noErr then begin
  335.                     HLock( data );
  336.                     err := MyFSRead( rn, filelen, data^ );
  337.                     HUnlock( data );
  338.                 end;
  339.             end;
  340.             junk := FSClose( rn );
  341.         end;
  342.         if err <> noErr then begin
  343.             MDisposeHandle( data );
  344.         end;
  345.         MyFSReadFile := err;
  346.     end;
  347.  
  348.     procedure MyResolveAliasFile (var fs: FSSpec);
  349.         var
  350.             isfolder, wasalias: boolean;
  351.             temp: FSSpec;
  352.             gv: longint;
  353.             oe: OSErr;
  354.     begin
  355.         if (Gestalt(gestaltAliasMgrAttr, gv) = noErr) & (BTST(gv, gestaltAliasMgrPresent)) then begin
  356.             temp := fs;
  357.             oe := ResolveAliasFile(fs, true, isfolder, wasalias);
  358.             if oe <> noErr then begin
  359.                 fs := temp;
  360.             end;
  361.         end;
  362.     end;
  363.  
  364.     function MyGetCatInfo (vrn: integer; dirID: longint; var name: Str63; index: integer; var pb: CInfoPBRec): OSErr;
  365.     begin
  366.         pb.ioVRefNum := vrn;
  367.         pb.ioDirID := dirID;
  368.         pb.ioNamePtr := @name;
  369.         pb.ioFDirIndex := index;
  370.         MyGetCatInfo := PBGetCatInfoSync(@pb);
  371.     end;
  372.  
  373.     function FSpGetParID( const spec: FSSpec; var dirID: longint ): OSErr;
  374.         var
  375.             err: OSErr;
  376.             pb: CInfoPBRec;
  377.     begin
  378.         err := FSpGetCatInfo( spec, pb );
  379.         if err = noErr then begin
  380.             dirID := pb.ioDrParID;
  381.         end;
  382.         FSpGetParID := err;
  383.     end;
  384.     
  385.     function FSpGetDirID( const spec: FSSpec; var dirID: longint ): OSErr;
  386.         var
  387.             err: OSErr;
  388.             pb: CInfoPBRec;
  389.     begin
  390.         err := FSpGetCatInfo( spec, pb );
  391.         if err = noErr then begin
  392.             if pb.ioFlAttrib and ioDirMask <> 0 then begin
  393.                 dirID := pb.ioDrDirID;
  394.             end else begin
  395.                 err := fnfErr;
  396.             end;
  397.         end;
  398.         FSpGetDirID := err;
  399.     end;
  400.     
  401.     function FSpGetCatInfo (const fs: FSSpec; var pb: CInfoPBRec): OSErr;
  402.     begin
  403.         pb.ioVRefNum := fs.vRefNum;
  404.         pb.ioDirID := fs.parID;
  405.         pb.ioNamePtr := @fs.name;
  406.         pb.ioFDirIndex := 0;
  407.         FSpGetCatInfo := PBGetCatInfoSync(@pb);
  408.     end;
  409.     
  410.     function FSpGetIndCatInfo (var fs: FSSpec; index: integer; var pb: CInfoPBRec): OSErr;
  411.     begin
  412.         pb.ioVRefNum := fs.vRefNum;
  413.         pb.ioDirID := fs.parID;
  414.         pb.ioNamePtr := @fs.name;
  415.         pb.ioFDirIndex := index;
  416.         FSpGetIndCatInfo := PBGetCatInfoSync(@pb);
  417.     end;
  418.  
  419.     function FSpSetCatInfo (const spec: FSSpec; var pb: CInfoPBRec): OSErr;
  420.     begin
  421.         pb.ioVRefNum := spec.vRefNum;
  422.         pb.ioDirID := spec.parID;
  423.         pb.ioNamePtr := @spec.name;
  424.         FSpSetCatInfo := PBSetCatInfoSync(@pb);
  425.     end;
  426.  
  427.     function MyFSMakeFSSpec (vrn: integer; dirID: longint; name: Str255; var fs: FSSpec): OSErr;
  428.         var
  429.             pb: CInfoPBRec;
  430.             oe: OSErr;
  431.             gv: longint;
  432.     begin
  433.         if (Gestalt(gestaltFSAttr, gv) = noErr) & (BTST(gv, gestaltHasFSSpecCalls)) then begin
  434.             oe := FSMakeFSSpec(vrn, dirID, name, fs);
  435.         end else begin
  436.             oe := MyGetCatInfo(vrn, dirID, name, 0, pb);
  437.             if (oe = noErr) then begin
  438.                 fs.vRefNum := pb.ioVRefNum;
  439.                 fs.parID := pb.ioFlParID;
  440.                 fs.name := name;
  441.             end;
  442.         end;
  443.         MyFSMakeFSSpec := oe;
  444.     end;
  445.  
  446.     procedure MyGetModDate (const spec: FSSpec; var moddate: longint);
  447.         var
  448.             err: OSErr;
  449.             pb: CInfoPBRec;
  450.     begin
  451.         err := FSpGetCatInfo( spec, pb );
  452.         if err = noErr then begin
  453.             moddate := pb.ioFlMdDat
  454.         end else begin
  455.             moddate := $80000000;
  456.         end;
  457.     end;
  458.  
  459.     function CopyData (src, dst: integer; len: longint): OSErr;
  460.         const
  461.             buffer_len = 4096;
  462.         var
  463.             buffer: array[1..buffer_len] of SignedByte;
  464.             l: longint;
  465.             oe: OSErr;
  466.     begin
  467.         oe := noErr;
  468.         while (len > 0) & (oe = noErr) do begin
  469.             if len > SizeOf(buffer) then begin
  470.                 l := SizeOf(buffer);
  471.             end else begin
  472.                 l := len;
  473.             end;
  474.             oe := FSRead(src, l, @buffer);
  475.             if (l = 0) & (oe = noErr) then begin
  476.                 oe := -1;
  477.             end;
  478.             if oe = noErr then begin
  479.                 oe := MyFSWrite(dst, l, @buffer);
  480.             end;
  481.             len := len - l;
  482.         end;
  483.         CopyData := oe;
  484.     end;
  485.  
  486.     function DuplicateFile (const org, new: FSSpec): OSErr;
  487.         const
  488.             fdInited = $0100;
  489.         var
  490.             oe, ooe: OSErr;
  491.             fi: FInfo;
  492.             pb: CInfoPBRec;
  493.             orn, nrn: integer;
  494.             rlen, dlen: longint;
  495.     begin
  496.         oe := FSpGetFInfo(org, fi);
  497.         if oe = noErr then begin
  498.             oe := FSpCreate(new, fi.fdCreator, fi.fdType, 0);
  499.             fi.fdFlags := band(fi.fdFlags, GoodBNOT(fdInited));
  500.             oe := FSpSetFInfo(new, fi);
  501.         end;
  502.         if oe = noErr then begin
  503.             oe := FSpGetCatInfo(org, pb);
  504.             if oe = noErr then begin
  505.                 dlen := pb.ioFlLgLen;
  506.                 rlen := pb.ioFlRLgLen;
  507.                 oe := FSpSetCatInfo( new, pb);
  508.             end;
  509.  
  510.             if oe = noErr then begin
  511.                 oe := FSpOpenDF(org, fsRdPerm, orn);
  512.                 if oe = noErr then begin
  513.                     oe := FSpOpenDF(new, fsWrPerm, nrn);
  514.                     if oe = noErr then begin
  515.                         oe := CopyData(orn, nrn, dlen);
  516.                         ooe := FSClose(nrn);
  517.                         if oe = noErr then begin
  518.                             ooe := oe;
  519.                         end;
  520.                     end;
  521.                     ooe := FSClose(orn);
  522.                 end;
  523.             end;
  524.  
  525.             if oe = noErr then begin
  526.                 oe := FSpOpenRF(org, fsRdPerm, orn);
  527.                 if oe = noErr then begin
  528.                     oe := FSpOpenRF(new, fsWrPerm, nrn);
  529.                     if oe = noErr then begin
  530.                         oe := CopyData(orn, nrn, rlen);
  531.                         ooe := FSClose(nrn);
  532.                         if oe = noErr then begin
  533.                             ooe := oe;
  534.                         end;
  535.                     end;
  536.                     ooe := FSClose(orn);
  537.                 end;
  538.             end;
  539.  
  540.             if oe <> noErr then begin
  541.                 ooe := FSpDelete(new);
  542.             end;
  543.         end;
  544.         DuplicateFile := oe;
  545.     end;
  546.  
  547.     function MyFSWriteAt (refnum: integer; mode: integer; pos, len: longint; p: Ptr): OSErr;
  548.         var
  549.             pb: ParamBlockRec;
  550.             oe: OSErr;
  551.     begin
  552.         pb.ioRefNum := refnum;
  553.         pb.ioBuffer := p;
  554.         pb.ioReqCount := len;
  555.         pb.ioPosMode := mode;
  556.         pb.ioPosOffset := pos;
  557.         oe := PBWriteSync(@pb);
  558.         if (oe = noErr) & (pb.ioActCount <> len) then begin
  559.             oe := -1;
  560.         end;
  561.         MyFSWriteAt := oe;
  562.     end;
  563.  
  564.     const
  565.         maxk = $70000000 div 1024;
  566.  
  567.     function MultiplyAllocation (blocks, blocksize: longint): longint; { result in k }
  568.         var
  569.             size: longint;
  570.     begin
  571.         blocks := BAND(BSR(blocks, 1), $00007FFF); { div 2 }
  572.         blocksize := BAND(BSR(blocksize, 9), $007FFFFF); { div 512 }
  573.         if (blocksize > 256) & (blocks > 256) then begin
  574.             size := (blocksize div 16) * (blocks div 16);
  575.             if size > maxk div 256 then begin
  576.                 size := maxk div 256;
  577.             end;
  578.             size := size * 256;
  579.         end else begin
  580.             size := blocksize * blocks; { in k }
  581.             if size > maxk then begin
  582.                 size := maxk;
  583.             end;
  584.         end;
  585.         MultiplyAllocation := size;
  586.     end;
  587.  
  588.     function OldDiskFreeSpace (vrn: integer): longint; { result in k }
  589.         var
  590.             err: OSErr;
  591.             pb: HParamBlockRec;
  592.             free: longint;
  593.     begin
  594.         free := maxk;
  595.         pb.ioNamePtr := nil;
  596.         pb.ioVRefNum := vrn;
  597.         pb.ioVolIndex := 0;
  598.         err := PBHGetVInfoSync(@pb);
  599.         if err = noErr then begin
  600.             free := MultiplyAllocation(pb.ioVFrBlk, pb.ioVAlBlkSiz);
  601.         end;
  602.         OldDiskFreeSpace := free;
  603.     end;
  604.  
  605.     function DiskFreeSpace (vrn: integer): longint; { result in k }
  606.         var
  607.             err: OSErr;
  608.             free: longint;
  609.     begin
  610.         err := GetVInfo(vrn, nil, vrn, free);
  611.         if err <> noErr then begin
  612.             free := maxk;
  613.         end else begin
  614.             if free < 0 then begin
  615.                 free := maxk;
  616.             end else begin
  617.                 free := free div 1024;
  618.                 if free > maxk then begin
  619.                     free := maxk;
  620.                 end;
  621.             end;
  622.         end;
  623.         DiskFreeSpace := free;
  624.     end;
  625.  
  626.     function DiskSize (vrn: integer): longint; { result in k }
  627.         var
  628.             err: OSErr;
  629.             pb: HParamBlockRec;
  630.             size: longint;
  631.     begin
  632.         size := 0;
  633.         pb.ioNamePtr := nil;
  634.         pb.ioVRefNum := vrn;
  635.         pb.ioVolIndex := 0;
  636.         err := PBHGetVInfoSync(@pb);
  637.         if err = noErr then begin
  638.             size := MultiplyAllocation(pb.ioVNmAlBlks, pb.ioVAlBlkSiz);
  639.         end;
  640.         DiskSize := size;
  641.     end;
  642.  
  643.     function BlessSystemFolder (vrn: integer; dirID: longint): OSErr;
  644.         var
  645.             err: OSErr;
  646.             pb: HParamBlockRec;
  647.     begin
  648.         pb.ioNamePtr := nil;
  649.         pb.ioVRefNum := vrn;
  650.         pb.ioVolIndex := 0;
  651.         err := PBHGetVInfoSync(@pb);
  652.         if err = noErr then begin
  653.             pb.ioVFndrInfo[1] := dirID;  { ARGHHHHHHH! }
  654.             err := PBSetVInfoSync(@pb);
  655.         end;
  656.         BlessSystemFolder := err;
  657.     end;
  658.  
  659.     function SameFSSpec (const fs1, fs2: FSSpec): boolean;
  660.     begin
  661.         SameFSSpec := (fs1.vRefNum = fs2.vRefNum) & (fs1.parID = fs2.parID) & (IUEqualString(fs1.name, fs2.name) = 0);
  662.     end;
  663.  
  664.     function GetDirID (wdrn: integer; var vrn: integer; var dirID: longint): OSErr;
  665.         var
  666.             procID: longint;
  667.             oe: OSErr;
  668.     begin
  669.         oe := GetWDInfo(wdrn, vrn, dirID, procID);
  670.         if oe <> noErr then begin
  671.             vrn := wdrn;
  672.             dirID := 0;
  673.         end;
  674.         GetDirID := oe;
  675.     end;
  676.  
  677.     function FSpGetFolderDirID( const spec: FSSpec; var dirID: longint ): OSErr;
  678.         var
  679.             err: OSErr;
  680.             pb: CInfoPBRec;
  681.     begin
  682.         dirID := -10;
  683.         err := FSpGetCatInfo( spec, pb );
  684.         if err = noErr then begin
  685.             if (pb.ioFlAttrib and ioDirMask) = 0 then begin
  686.                 err := fnfErr;
  687.             end else begin
  688.                 dirID := pb.ioDrDirID;
  689.             end;
  690.         end;
  691.         FSpGetFolderDirID := err;
  692.     end;
  693.     
  694.     function GetVolInfo (var name: Str63; var vrn: integer; index: integer; var CrDate: longint): OSErr;
  695.         var
  696.             pb: ParamBlockRec;
  697.             oe: OSErr;
  698.     begin
  699.         if (name <> '') & (name[length(name)] <> ':') then begin
  700.             name := concat(name, ':');
  701.         end;
  702.         pb.ioNamePtr := @name;
  703.         pb.ioVRefNum := vrn;
  704.         pb.ioVolIndex := index;
  705.         oe := PBGetVInfoSync(@pb);
  706.         if oe = noErr then begin
  707.             vrn := pb.ioVRefNum;
  708.             CrDate := pb.ioVCrDate;
  709.         end;
  710.         GetVolInfo := oe;
  711.     end;
  712.  
  713. {$PUSH}
  714. {$ALIGN MAC68K}
  715.     type
  716.         VolParamsRecord = packed record
  717.                     version: integer;
  718.                     attrib: longint;
  719.                     localhand: Handle;
  720.                     address: AddrBlock;
  721.                 end;
  722. {$ALIGN RESET}
  723. {$POP}
  724.                 
  725.     function GetVolumeAddrBlock(vrn: integer; index: integer; var addr: AddrBlock): OSErr;
  726.         var
  727.             err: OSErr;
  728.             pb: HParamBlockRec;
  729.             volparams: VolParamsRecord;
  730.     begin
  731.         longint(addr) := 0;
  732.         pb.ioNamePtr := nil;
  733.         pb.ioVRefNum := vrn;
  734.         pb.ioVolIndex := index;
  735.         err := PBHGetVInfoSync(@pb);
  736.         if err = noErr then begin
  737.             pb.ioNamePtr := nil;
  738.             pb.ioBuffer := @volparams;
  739.             pb.ioReqCount := SizeOf(volparams);
  740.             err := PBHGetVolParmsSync(@pb);
  741.         end;
  742.         if err = noErr then begin
  743.             addr := volparams.address;
  744.         end;
  745.         GetVolumeAddrBlock := err;
  746.     end;
  747.     
  748.     function ScanDirectory (fs: FSSpec; doit: ScanProc): OSErr;
  749.         var
  750.             pb: CInfoPBRec;
  751.             ret, folder: boolean;
  752.             path: Str255;
  753.         procedure Scan (dirID: longint);
  754.             var
  755.                 index, len: integer;
  756.                 oe: OSErr;
  757.         begin
  758.             index := 1;
  759.             repeat
  760.                 with pb do begin
  761.                     oe := MyGetCatInfo(fs.vRefNum, dirID, fs.name, index, pb);
  762.                     index := index + 1;
  763.                     if oe = noErr then begin
  764.                         fs.parID := dirID;
  765.                         folder := BAND(pb.ioFlAttrib, ioDirMask) <> 0;
  766.                         ret := doit(fs, folder, path, pb);
  767.                         if folder and ret then begin
  768.                             len := length(path);
  769.                             path := concat(path, fs.name, ':');
  770.                             Scan(pb.ioDirID);
  771.                             path[0] := chr(len);
  772.                         end else if not folder and ret then begin
  773.                             index := index - 1;
  774.                         end;
  775.                     end;
  776.                 end;
  777.             until oe <> noErr;
  778.         end;
  779.         var
  780.             err: OSErr;
  781.             dummy: boolean;
  782.     begin
  783.         path := ':';
  784.         if fs.name <> '' then begin
  785.             err := FSpGetCatInfo(fs, pb);
  786.             if err = noErr then begin
  787.                 if BAND(pb.ioFlAttrib, ioDirMask) <> 0 then begin
  788.                     Scan(pb.ioDirID);
  789.                 end else begin
  790.                     dummy := doit(fs, false, path, pb);
  791.                 end;
  792.             end;
  793.         end else begin
  794.             Scan(fs.parID);
  795.             err := noErr;
  796.         end;
  797.         ScanDirectory := err;
  798.     end;
  799.  
  800.     function RemoveResourceFork( const spec: FSSpec ): OSErr;
  801.         var
  802.             err, err2: OSErr;
  803.             refnum: integer;
  804.     begin
  805.         err:=FSpOpenRF( spec, fsRdWrPerm, refnum );
  806.         if err = noErr then begin
  807.             err := SetEOF( refnum, 0 );
  808.             err2 := FSClose( refnum );
  809.             if err = noErr then begin
  810.                 err := err2;
  811.             end;
  812.         end;
  813.         RemoveResourceFork := err;
  814.     end;
  815.     
  816. end.